Complete Linux/Complete Linux.iso/docs/devel/lisp/kcl_tar.z/kcl_tar/c/character.d

Text File | 1987-06-04 | 13.1 KB | 652 lines

/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/

/*
    character.d

    character routines
*/

#include "include.h"

object STreturn;
object STspace;
object STrubout;
object STpage;
object STtab;
object STbackspace;
object STlinefeed;

object STnewline;

@(defun standard_char_p (c)
    int i;
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    i = char_code(c);
    if (' ' <= i && i < '\177' || i == '\n')
        @(return Ct)
    @(return Cnil)
@)

@(defun graphic_char_p (c)
    int i;
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    i = char_code(c);
    if (' ' <= i && ' ' < '\177')
        @(return Ct)
    @(return Cnil)
@)

@(defun string_char_p (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    @(return Ct)
@)

@(defun alpha_char_p (c)
    int i;
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    i = char_code(c);
    if (isalpha(i))
        @(return Ct)
    else
        @(return Cnil)
@)

@(defun upper_case_p (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    if (isUpper(char_code(c)))
        @(return Ct)
    @(return Cnil)
@)

@(defun lower_case_p (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    if (isLower(char_code(c)))
        @(return Ct)
    @(return Cnil)
@)

@(defun both_case_p (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    if (isUpper(char_code(c)) || isLower(char_code(c)))
        @(return Ct)
    else
        @(return Cnil)
@)

/*
    Digitp(i, r) returns the weight of code i
    as a digit of radix r.
    If r > 36 or i is not a digit, -1 is returned.
*/
digitp(i, r)
int i, r;
{
    if ('0' <= i && i <= '9' && 1 < r && i < '0' + r)
        return(i - '0');
    if ('A' <= i && 10 < r && r <= 36 && i < 'A' + (r - 10))
        return(i - 'A' + 10);
    if ('a' <= i && 10 < r && r <= 36 && i < 'a' + (r - 10))
        return(i - 'a' + 10);
    return(-1);
}

@(defun digit_char_p (c &optional (r `make_fixnum(10)`))
    int d;
@
    check_type_character(&c);
    check_type_non_negative_integer(&r);
    if (type_of(r) == t_bignum)
        @(return Cnil)
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    d = digitp(char_code(c), fix(r));
    if (d < 0)
        @(return Cnil)
    @(return `make_fixnum(d)`)
@)

@(defun alphanumericp (c)
    int i;
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    i = char_code(c);
    if (isalphanum(i))
        @(return Ct)
    else
        @(return Cnil)
@)

bool
char_eq(x, y)
object x, y;
{
    return(char_code(x) == char_code(y)
        && char_bits(x) == char_bits(y)
        && char_font(x) == char_font(y));
}

@(defun char_eq (c &rest)
    int i;
@
    for (i = 0;  i < narg;  i++)
        check_type_character(&vs_base[i]);
    for (i = 1;  i < narg;  i++)
        if (!char_eq(vs_base[i-1], vs_base[i]))
            @(return Cnil)
    @(return Ct)
@)

@(defun char_neq (c &rest)
    int i, j;
@
    for (i = 0;  i < narg;  i++)
        check_type_character(&vs_base[i]);
    if (narg == 0)
        @(return Ct)
    for (i = 1;  i < narg;  i++)
        for (j = 0;  j < i;  j++)
            if (char_eq(vs_base[j], vs_base[i]))
                @(return Cnil)
    @(return Ct)
@)


int
char_cmp(x, y)
object x, y;
{
    if (char_font(x) < char_font(y))
        return(-1);
    if (char_font(x) > char_font(y))
        return(1);
    if (char_bits(x) < char_bits(y))
        return(-1);
    if (char_bits(x) > char_bits(y))
        return(1);
    if (char_code(x) < char_code(y))
        return(-1);
    if (char_code(x) > char_code(y))
        return(1);
    return(0);
}

Lchar_cmp(s, t)
int s, t;
{
    int narg, i;

    narg = vs_top - vs_base;
    if (narg == 0)
        too_few_arguments();
    for (i = 0; i < narg; i++)
        check_type_character(&vs_base[i]);
    for (i = 1; i < narg; i++)
        if (s*char_cmp(vs_base[i], vs_base[i-1]) < t) {
            vs_top = vs_base+1;
            vs_base[0] = Cnil;
            return;
        }
    vs_top = vs_base+1;
    vs_base[0] = Ct;
}

Lchar_l()  { Lchar_cmp( 1, 1); }
Lchar_g()  { Lchar_cmp(-1, 1); }
Lchar_le() { Lchar_cmp( 1, 0); }
Lchar_ge() { Lchar_cmp(-1, 0); }


bool
char_equal(x, y)
object x, y;
{
    int i, j;

    i = char_code(x);
    j = char_code(y);
    if (isLower(i))
        i -= 'a' - 'A';
    if (isLower(j))
        j -= 'a' - 'A';
    return(i == j);
}

@(defun char_equal (c &rest)
    int i;
@
    for (i = 0;  i < narg;  i++)
        check_type_character(&vs_base[i]);
    for (i = 1;  i < narg;  i++)
        if (!char_equal(vs_base[i-1], vs_base[i]))
            @(return Cnil)
    @(return Ct)
@)

@(defun char_not_equal (c &rest)
    int i, j;
@
    for (i = 0;  i < narg;  i++)
        check_type_character(&vs_base[i]);
    for (i = 1;  i < narg;  i++)
        for (j = 0;  j < i;  j++)
            if (char_equal(vs_base[j], vs_base[i]))
                @(return Cnil)
    @(return Ct)
@)


int
char_compare(x, y)
object x, y;
{
    int i, j;

    i = char_code(x);
    j = char_code(y);
    if (isLower(i))
        i -= 'a' - 'A';
    if (isLower(j))
        j -= 'a' - 'A';
    if (i < j)
        return(-1);
    else if (i == j)
        return(0);
    else
        return(1);
}

Lchar_compare(s, t)
int s, t;
{
    int narg, i;

    narg = vs_top - vs_base;
    if (narg == 0)
        too_few_arguments();
    for (i = 0; i < narg; i++)
        check_type_character(&vs_base[i]);
    for (i = 1; i < narg; i++)
        if (s*char_compare(vs_base[i], vs_base[i-1]) < t) {
            vs_top = vs_base+1;
            vs_base[0] = Cnil;
            return;
        }
    vs_top = vs_base+1;
    vs_base[0] = Ct;
}

Lchar_lessp()        { Lchar_compare( 1, 1); }
Lchar_greaterp()     { Lchar_compare(-1, 1); }
Lchar_not_greaterp() { Lchar_compare( 1, 0); }
Lchar_not_lessp()    { Lchar_compare(-1, 0); }


object
coerce_to_character(x)
object x;
{
BEGIN:
    switch (type_of(x)) {
    case t_fixnum:
        if (0 <= fix(x) && fix(x) < CHCODELIM)
            return(code_char(fix(x)));
        break;

    case t_character:
        return(x);

    case t_symbol:
    case t_string:
        if (x->st.st_fillp == 1)
            return(code_char(x->ust.ust_self[0]));
        break;
    }
    vs_push(x);
    x = wrong_type_argument(Scharacter, x);
    vs_pop;
    goto BEGIN;
}

@(defun character (x)
@
    @(return `coerce_to_character(x)`)
@)

@(defun char_code (c)
@
    check_type_character(&c);
    @(return `make_fixnum(char_code(c))`)
@)

@(defun char_bits (c)
@
    check_type_character(&c);
    @(return `make_fixnum(char_bits(c))`)
@)

@(defun char_font (c)
@
    check_type_character(&c);
    @(return `make_fixnum(char_font(c))`)
@)

@(defun code_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
    object x;
@
    check_type_non_negative_integer(&c);
    check_type_non_negative_integer(&b);
    check_type_non_negative_integer(&f);
    if (type_of(c) == t_bignum)
        @(return Cnil)
    if (type_of(b) == t_bignum)
        @(return Cnil)
    if (type_of(f) == t_bignum)
        @(return Cnil)
    if (fix(c)>=CHCODELIM || fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
        @(return Cnil)
    if (fix(b) == 0 && fix(f) == 0)
        @(return `code_char(fix(c))`)
    x = alloc_object(t_character);
    char_code(x) = fix(c);
    char_bits(x) = fix(b);
    char_font(x) = fix(f);
    @(return x)
@)

@(defun make_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
    object x;
    int code;
@
    check_type_character(&c);
    code = char_code(c);
    check_type_non_negative_integer(&b);
    check_type_non_negative_integer(&f);
    if (type_of(b) == t_bignum)
        @(return Cnil)
    if (type_of(f) == t_bignum)
        @(return Cnil)
    if (fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
        @(return Cnil)
    if (fix(b) == 0 && fix(f) == 0)
        @(return `code_char(code)`)
    x = alloc_object(t_character);
    char_code(x) = code;
    char_bits(x) = fix(b);
    char_font(x) = fix(f);
    @(return x)
@)

@(defun char_upcase (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return c)
    if (isLower(char_code(c)))
        @(return `code_char(char_code(c) - ('a' - 'A'))`)
    else
        @(return c)
@)

@(defun char_downcase (c)
@
    check_type_character(&c);
    if (char_font(c) != 0 || char_bits(c) != 0)
        @(return Cnil)
    if (isUpper(char_code(c)))
        @(return `code_char(char_code(c) + ('a' - 'A'))`)
    else
        @(return c)
@)

int
digit_weight(w, r)
int w, r;
{
    if (r < 2 || r > 36 || w < 0 || w >= r)
        return(-1);
    if (w < 10)
        return(w + '0');
    else
        return(w - 10 + 'A');
}

@(defun digit_char (w
            &optional
            (r `make_fixnum(10)`)
            (f `make_fixnum(0)`))
    object x;
    int dw;
@
    check_type_non_negative_integer(&w);
    check_type_non_negative_integer(&r);
    check_type_non_negative_integer(&f);
    if (type_of(w) == t_bignum)
        @(return Cnil)
    if (type_of(r) == t_bignum)
        @(return Cnil)
    if (type_of(f) == t_bignum)
        @(return Cnil)
    dw = digit_weight(fix(w), fix(r));
    if (dw < 0)
        @(return Cnil)
    if (fix(f) >= CHFONTLIM)
        @(return Cnil)
    if (fix(f) == 0)
        @(return `code_char(dw)`)
    x = alloc_object(t_character);
    char_code(x) = dw;
    char_bits(x) = 0;
    char_font(x) = fix(f);
    @(return x)
@)

@(defun char_int (c)
    int i;
@
    check_type_character(&c);
    i = (char_font(c)*CHBITSLIM + char_bits(c))*CHCODELIM
      + char_code(c);
    @(return `make_fixnum(i)`)
@)

@(defun int_char (x)
    int i, c, b, f;
@
    check_type_non_negative_integer(&x);
    if (type_of(x) == t_bignum)
        @(return Cnil)
    i = fix(x);
    c = i % CHCODELIM;
    i /= CHCODELIM;
    b = i % CHBITSLIM;
    i /= CHBITSLIM;
    f = i % CHFONTLIM;
    i /= CHFONTLIM;
    if (i > 0)
        @(return Cnil)
    if (b == 0 && f == 0)
        @(return `code_char(c)`)
    x = alloc_object(t_character);
    char_code(x) = c;
    char_bits(x) = b;
    char_font(x) = f;
    @(return x)
@)

@(defun char_name (c)
@
    check_type_character(&c);
    if (char_bits(c) != 0 || char_font(c) != 0)
        @(return Cnil)
    switch (char_code(c)) {
    case '\r':
        @(return STreturn)

    case ' ':
        @(return STspace)

    case '\177':
        @(return STrubout)

    case '\f':
        @(return STpage)

    case '\t':
        @(return STtab)

    case '\b':
        @(return STbackspace)

    case '\n':
        @(return STnewline)
    }
    @(return Cnil)
@)

@(defun name_char (s)
@
    s = coerce_to_string(s);
    if (string_equal(s, STreturn))
        @(return `code_char('\r')`)
    if (string_equal(s, STspace))
        @(return `code_char(' ')`)
    if (string_equal(s, STrubout))
        @(return `code_char('\177')`)
    if (string_equal(s, STpage))
        @(return `code_char('\f')`)
    if (string_equal(s, STtab))
        @(return `code_char('\t')`)
    if (string_equal(s, STbackspace))
        @(return `code_char('\b')`)
    if (string_equal(s, STlinefeed) || string_equal(s, STnewline))
        @(return `code_char('\n')`)
    @(return Cnil)
@)

@(defun char_bit (c n)
@
    check_type_character(&c);
    FEerror("Cannot get char-bit of ~S.", 1, c);
@)

@(defun set_char_bit (c n v)
@
    check_type_character(&c);
    FEerror("Cannot set char-bit of ~S.", 1, c);
@)

init_character()
{
    object ch;
    int i;

    for (i = 0;  i < CHCODELIM;  i++) {
        character_table[i].t = (short)t_character;
        character_table[i].ch_code = i;
        character_table[i].ch_font = 0;
        character_table[i].ch_bits = 0;
    }
#ifdef AV
    for (i = -128;  i < 0;  i++) {
        character_table[i].t = (short)t_character;
        character_table[i].ch_code = i+CHCODELIM;
        character_table[i].ch_font = 0;
        character_table[i].ch_bits = 0;
    }
#endif

     make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM));
     make_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM));
     make_constant("CHAR-BITS-LIMIT", make_fixnum(CHBITSLIM));

    STreturn = make_simple_string("RETURN");
    enter_mark_origin(&STreturn);
    STspace = make_simple_string("SPACE");
    enter_mark_origin(&STspace);
    STrubout = make_simple_string("RUBOUT");
    enter_mark_origin(&STrubout);
    STpage = make_simple_string("PAGE");
    enter_mark_origin(&STpage);
    STtab = make_simple_string("TAB");
    enter_mark_origin(&STtab);
    STbackspace = make_simple_string("BACKSPACE");
    enter_mark_origin(&STbackspace);
    STlinefeed = make_simple_string("LINEFEED");
    enter_mark_origin(&STlinefeed);

    STnewline = make_simple_string("NEWLINE");
    enter_mark_origin(&STnewline);

    make_constant("CHAR-CONTROL-BIT", make_fixnum(0));
    make_constant("CHAR-META-BIT", make_fixnum(0));
    make_constant("CHAR-SUPER-BIT", make_fixnum(0));
    make_constant("CHAR-HYPER-BIT", make_fixnum(0));
}

init_character_function()
{
    make_function("STANDARD-CHAR-P", Lstandard_char_p);
    make_function("GRAPHIC-CHAR-P", Lgraphic_char_p);
    make_function("STRING-CHAR-P", Lstring_char_p);
    make_function("ALPHA-CHAR-P", Lalpha_char_p);
    make_function("UPPER-CASE-P", Lupper_case_p);
    make_function("LOWER-CASE-P", Llower_case_p);
    make_function("BOTH-CASE-P", Lboth_case_p);
    make_function("DIGIT-CHAR-P", Ldigit_char_p);
    make_function("ALPHANUMERICP", Lalphanumericp);
    make_function("CHAR=", Lchar_eq);
    make_function("CHAR/=", Lchar_neq);
    make_function("CHAR<", Lchar_l);
    make_function("CHAR>", Lchar_g);
    make_function("CHAR<=", Lchar_le);
    make_function("CHAR>=", Lchar_ge);
    make_function("CHAR-EQUAL", Lchar_equal);
    make_function("CHAR-NOT-EQUAL", Lchar_not_equal);
    make_function("CHAR-LESSP", Lchar_lessp);
    make_function("CHAR-GREATERP", Lchar_greaterp);
    make_function("CHAR-NOT-GREATERP", Lchar_not_greaterp);
    make_function("CHAR-NOT-LESSP", Lchar_not_lessp);
    make_function("CHARACTER", Lcharacter);
    make_function("CHAR-CODE", Lchar_code);
    make_function("CHAR-BITS", Lchar_bits);
    make_function("CHAR-FONT", Lchar_font);
    make_function("CODE-CHAR", Lcode_char);
    make_function("MAKE-CHAR", Lmake_char);
    make_function("CHAR-UPCASE", Lchar_upcase);
    make_function("CHAR-DOWNCASE", Lchar_downcase);
    make_function("DIGIT-CHAR", Ldigit_char);
    make_function("CHAR-INT", Lchar_int);
    make_function("INT-CHAR", Lint_char);
    make_function("CHAR-NAME", Lchar_name);
    make_function("NAME-CHAR", Lname_char);
    make_function("CHAR-BIT", Lchar_bit);
    make_function("SET-CHAR-BIT", Lset_char_bit);
}